home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / UCB Logo 3.0 ƒ / sources / standard source / paren.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-08-14  |  9.1 KB  |  315 lines  |  [TEXT/ttxt]
  1. /*
  2.  *      paren.c            logo parenthesizing module        dko
  3.  *
  4.  *    Copyright (C) 1993 by the Regents of the University of California
  5.  *
  6.  *      This program is free software; you can redistribute it and/or modify
  7.  *      it under the terms of the GNU General Public License as published by
  8.  *      the Free Software Foundation; either version 2 of the License, or
  9.  *      (at your option) any later version.
  10.  *  
  11.  *      This program is distributed in the hope that it will be useful,
  12.  *      but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.  *      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.  *      GNU General Public License for more details.
  15.  *  
  16.  *      You should have received a copy of the GNU General Public License
  17.  *      along with this program; if not, write to the Free Software
  18.  *      Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  *
  20.  */
  21.  
  22. #include "logo.h"
  23. #include "globals.h"
  24.  
  25. #define assign(to, from)    to = reref(to, from)
  26.  
  27. NODE *the_generation;
  28.  
  29. /* Set the line pointer for a tree.
  30.  */ 
  31. void make_line(NODE *tree, NODE *line) {
  32. /*    setobject(tree, line);    BH */
  33.     setobject(tree, NIL);
  34.     tree->n_obj = line;
  35.     settype(tree, LINE);
  36. }
  37.  
  38. void untreeify(NODE *node) {
  39.     settreepair__tree(node, NIL);
  40.     settype(node, CONS);
  41. }
  42.  
  43. void untreeify_line(NODE *line) {
  44.     if (line != NIL && is_list(line)) {
  45.     untreeify_line(car(line));
  46.     untreeify_line(cdr(line));
  47.     untreeify(line);
  48.     }
  49. }
  50.  
  51. void untreeify_proc(NODE *procname) {
  52.  
  53.     NODE *body = bodylist__procnode(procnode__caseobj(procname));
  54.     NODE *body_ptr;
  55.  
  56.     for (body_ptr = body; body_ptr != NIL; body_ptr = cdr(body_ptr)) {
  57.     untreeify_line(car(body_ptr));
  58.     }
  59.     untreeify(body);
  60. }
  61.  
  62. /* Treeify a body by appending the trees of the lines.
  63.  */ 
  64. void make_tree_from_body(NODE *body) {
  65.  
  66.     NODE *body_ptr, *end_ptr = NIL, *tree = NIL;
  67.  
  68.     if (body == NIL ||
  69.     (is_tree(body) && generation__tree(body) == the_generation))
  70.         return;
  71.     for (body_ptr = body; body_ptr != NIL; body_ptr = cdr(body_ptr)) {
  72.     tree = car(body_ptr);
  73.     assign(this_line, tree);
  74.     make_tree(tree);
  75.     if (is_tree(tree)) {
  76.         tree = tree__tree(tree);
  77.         make_line(tree, car(body_ptr));
  78.         if (end_ptr == NIL)
  79.         settree__tree(body, tree);
  80.         else
  81.         setcdr(end_ptr, tree);
  82.         if (generation__tree(car(body_ptr)) == UNBOUND)
  83.         setgeneration__tree(body, UNBOUND);
  84.         untreeify(car(body_ptr));
  85.         while (cdr(tree) != NIL)
  86.         tree = cdr(tree);
  87.         end_ptr = tree;
  88.     } else {    /* error while treeifying */
  89.         untreeify(body);
  90.         return;
  91.     }
  92.     }
  93.     settype(body, TREE);
  94. }
  95.  
  96. BOOLEAN tree_dk_how;
  97.  
  98. /* Treeify a list of tokens (runparsed or not).
  99.  */ 
  100. void make_tree(NODE *list) {
  101.  
  102.     NODE *tree = NIL;
  103.     NODE *paren_line(NODE *);
  104.  
  105.     if (list == NIL ||
  106.     (is_tree(list) && generation__tree(list) == the_generation))
  107.         return;
  108.     if (!runparsed(list)) make_runparse(list);
  109.     tree_dk_how = FALSE;
  110.     tree = paren_line(parsed__runparse(list));
  111.     if (tree != NIL && tree != UNBOUND) {
  112.     settype(list, TREE);
  113.     settree__tree(list, tree);
  114.     if (tree_dk_how || stopping_flag==THROWING)
  115.         setgeneration__tree(list, UNBOUND);
  116.     }
  117. }
  118.  
  119.  
  120. /* Fully parenthesize a complete line, i.e. transform it from a flat list
  121.  * to a tree.
  122.  */ 
  123. NODE *paren_line(NODE *line) {
  124.  
  125.     NODE *retval = NIL, *save = line;
  126.     NODE *paren_expr(NODE **expr, BOOLEAN inparen);
  127.     NODE *paren_infix(NODE *left, NODE **rest, int old_pri, BOOLEAN inparen);
  128.  
  129.     if (line == NIL) return line;
  130.     retval = paren_expr(&line, FALSE);
  131.     if (NOT_THROWING && retval != UNBOUND) {
  132.     retval = paren_infix(retval, &line, -1, FALSE);
  133.     retval = cons(retval, paren_line(line));
  134.     }
  135.     return retval;
  136. }
  137.  
  138. /* Parenthesize an expression.  Set expr to the node after the first full
  139.  * expression.
  140.  */ 
  141. NODE *paren_expr(NODE **expr, BOOLEAN inparen) {
  142.  
  143.     NODE *first = NIL, *tree = NIL, *proc, *retval, *save = *expr;
  144.     NODE **ifnode = (NODE **)NIL;
  145.     NODE *gather_args(NODE *, NODE **, BOOLEAN, NODE **);
  146.     NODE *paren_infix(NODE *, NODE **, int, BOOLEAN);
  147.  
  148.     if (*expr == NIL) {
  149.     if (inparen) err_logo(PAREN_MISMATCH, NIL);
  150.     return *expr;
  151.     }
  152.     first = valref(car(*expr));
  153.     pop(*expr);
  154.     if (nodetype(first) == CASEOBJ && !numberp(first)) {
  155.     if (first == Left_Paren) {
  156.         deref(first);
  157.         tree = paren_expr(expr, TRUE);
  158.         tree = paren_infix(tree, expr, -1, TRUE);
  159.         if (*expr == NIL)
  160.         err_logo(PAREN_MISMATCH, NIL);
  161.         else if (car(*expr) != Right_Paren)
  162.         {
  163.         int parens;
  164.  
  165.         err_logo(TOO_MUCH, NIL);    /* throw the rest away */
  166.         for (parens = 0; *expr; pop(*expr))
  167.             if (car(*expr) == Left_Paren)
  168.             parens++;
  169.             else if (car(*expr) == Right_Paren)
  170.             if (parens-- == 0) break;
  171.         }
  172.         else
  173.         pop(*expr);
  174.         retval = tree;
  175.     } else if (first == Right_Paren) {
  176.         deref(first);
  177.         err_logo(UNEXPECTED_PAREN, NIL);
  178.         if (inparen) push(first, *expr);
  179.         retval = NIL;
  180.     } else if (first == Minus_Sign) {
  181.         deref(first);
  182.         push(Minus_Tight, *expr);
  183.         retval = paren_infix(make_intnode((FIXNUM) 0), expr, -1, inparen);
  184.     } else {    /* it must be a procedure */
  185.         if (procnode__caseobj(first) == UNDEFINED && NOT_THROWING &&
  186.         first != Null_Word)
  187.             silent_load(first, NULL);    /* try ./<first>.lg */
  188.         if (procnode__caseobj(first) == UNDEFINED && NOT_THROWING &&
  189.         first != Null_Word)
  190.             silent_load(first, logolib); /* try <logolib>/<first> */
  191.         proc = procnode__caseobj(first);
  192.         if (proc == UNDEFINED && NOT_THROWING) {
  193.         retval = cons(first, NIL);
  194.         tree_dk_how = TRUE;
  195.         } else {
  196.     /* Kludge follows to turn IF to IFELSE sometimes. */
  197.         if (first == If) {
  198.             ifnode = &first;
  199.         }
  200.         retval = gather_args(proc, expr, inparen, ifnode);
  201.         if (retval != UNBOUND) {
  202.             retval = cons(first, retval);
  203.         }
  204.         }
  205.         deref(first);
  206.     }
  207.     } else if (is_list(first)) {   /* quoted list */
  208.     retval = make_quote(first);
  209.     deref(first);
  210.     } else {
  211.     unref(first);
  212.     return first;
  213.     }
  214.     return retval;
  215. }
  216.  
  217. /* Gather the correct number of arguments to proc into a list.  Set args to
  218.  * immediately after the last arg.
  219.  */ 
  220. NODE *gather_args(NODE *proc, NODE **args, BOOLEAN inparen, NODE **ifnode) {
  221.  
  222.     int min, max;
  223.     NODE *gather_some_args(int, int, NODE **, BOOLEAN, NODE **);
  224.     
  225.     if (nodetype(proc) == CONS) {
  226.     min = (inparen ? getint(minargs__procnode(proc))
  227.                : getint(dfltargs__procnode(proc)));
  228.     max = (inparen ? getint(maxargs__procnode(proc))
  229.                : getint(dfltargs__procnode(proc)));
  230.     } else { /* primitive */
  231.     min = (inparen ? getprimmin(proc) : getprimdflt(proc));
  232.     if (min < 0) {        /* special form */
  233.         return (*getprimfun(proc))(*args);
  234.     }
  235.     /* Kludge follows to allow EDIT and CO without input without paren */ 
  236.     if (getprimmin(proc) == OK_NO_ARG) min = 0;
  237.     max = (inparen ? getprimmax(proc) : getprimdflt(proc));
  238.     }
  239.     return gather_some_args(min, max, args, inparen, ifnode);
  240. }
  241.  
  242. /* Make a list of the next n expressions, where n is between min and max.
  243.  * Set args to immediately after the last expression.
  244.  */ 
  245. NODE *gather_some_args(int min, int max, NODE **args, BOOLEAN inparen,
  246.                NODE **ifnode)
  247. {
  248.     int parens;
  249.     NODE *paren_infix(NODE *left, NODE **rest, int old_pri, BOOLEAN inparen);
  250.  
  251.     if (*args == NIL || car(*args) == Right_Paren ||
  252.         (nodetype(car(*args)) == CASEOBJ &&
  253.          nodetype(procnode__caseobj(car(*args))) == INFIX)) {
  254.     if (min > 0) return cons(Not_Enough_Node, NIL);
  255.     } else if (max == 0) {
  256.     if (ifnode != (NODE **)NIL && is_list(car(*args))) {
  257.         /* if -> ifelse kludge */
  258.         NODE *retval;
  259.         err_logo(IF_WARNING, NIL);
  260.         assign(*ifnode, Ifelse);
  261.         retval = paren_expr(args, FALSE);
  262.         retval = paren_infix(retval, args, -1, inparen);
  263.         return cons(retval, gather_some_args(min, max, args,
  264.                          inparen, (NODE **)NIL));
  265.     }
  266.     } else {
  267.     if (max < 0) max = 0;   /* negative max means unlimited */
  268.     if (car(*args) != Right_Paren &&
  269.         (nodetype(car(*args)) != CASEOBJ ||
  270.          nodetype(procnode__caseobj(car(*args))) != INFIX)) {
  271.         NODE *retval = paren_expr(args, FALSE);
  272.         retval = paren_infix(retval, args, -1, inparen);
  273.         return cons(retval, gather_some_args(min - 1, max - 1, args,
  274.                          inparen, ifnode));
  275.     }
  276.     }
  277.     return NIL;
  278. }
  279.  
  280. /* Calculate the priority of a procedure.
  281.  */ 
  282. int priority(NODE *proc_obj) {
  283.  
  284.     NODE *proc;
  285.  
  286.     if (proc_obj == Minus_Tight) return 4;
  287.     if (nodetype(proc_obj) != CASEOBJ ||
  288.     (proc = procnode__caseobj(proc_obj)) == UNDEFINED ||
  289.     nodetype(proc) != INFIX)
  290.         return 0;
  291.     return (is_prim(proc) ? getprimpri(proc) : PREFIX_PRIORITY);
  292. }
  293.  
  294. /* Parenthesize an infix expression.  left_arg is the expression on the left
  295.  * (already parenthesized), and rest is a pointer to the list starting with the
  296.  * infix procedure, if it's there.  Set rest to after the right end of the
  297.  * infix expression.
  298.  */ 
  299. NODE *paren_infix(NODE *left_arg, NODE **rest, int old_pri, BOOLEAN inparen) {
  300.  
  301.     NODE *infix_proc, *retval;
  302.     int pri;
  303.  
  304.     if (*rest == NIL || !(pri = priority(infix_proc = car(*rest)))
  305.              || pri <= old_pri) 
  306.     return left_arg;
  307.     ref(infix_proc);
  308.     pop(*rest);
  309.     retval = paren_expr(rest, inparen);
  310.     retval = paren_infix(retval, rest, pri, inparen);
  311.     retval = cons_list(0,infix_proc, left_arg, retval, END_OF_LIST);
  312.     deref(infix_proc);
  313.     return paren_infix(retval, rest, old_pri, inparen);
  314. }
  315.